home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Hacks / Hacks ’92 / BNDL Hacks ƒ / source (THINK C & LISP) / svab.lisp < prev   
Encoding:
Text File  |  1992-06-19  |  12.0 KB  |  304 lines  |  [TEXT/CCL2]
  1. ;MCL code for fully functional prototypes of Flip A BNDL & Save A BNDL
  2. ;© 1992 - Michael S. Engber - All Rights Reserved
  3.  
  4. (oou-dependencies :records-u
  5.                   :macptr-u
  6.                   :traps-u)
  7.  
  8. (defun OSType-to-long (ostype)
  9.   (rlet ((buf :OSType))
  10.     (%put-ostype buf ostype)
  11.     (%get-unsigned-long buf)))
  12.  
  13. (defun long-to-OSType (long)
  14.   (rlet ((buf :OSType))
  15.     (%put-long buf long)
  16.     (%get-ostype buf)))
  17.  
  18. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19. ;;
  20.  
  21.  
  22. ;;Fills in the ProcessSerialNumber and FSSpec of the 1st process with
  23. ;;the specified signature & file type.
  24. ;;Returns t/nil indicating success/failure.
  25. ;;Based on sample code from IM VI p. 29-11
  26. (defun find-process (file-type signature psn fsspec)
  27.  
  28.   ;;Must coerce file-type to an in becuause the processType field of a
  29.   ;; ProcessInfoRec is defined as a long for some reason
  30.   (setf file-type (OSType-to-long file-type))
  31.  
  32.   ;;Must be sure that signature is a keyword so the eq test will work.
  33.   ;; (OSTypes can be passed as keywords or 4-char strings)
  34.   (setf signature (long-to-OSType (OSType-to-long signature)))
  35.  
  36.   (rlet ((pinfo :ProcessInfoRec
  37.                 :processInfoLength (rlength :ProcessInfoRec)
  38.                 :processName                 (%null-ptr)
  39.                 :processAppSpec              fsspec))
  40.     (pset psn :ProcessSerialNumber.highLongOfPSN 0)
  41.     (pset psn :ProcessSerialNumber.lowLongOfPSN #$kNoProcess)
  42.     (loop
  43.       (unless (zerop (#_GetNextProcess psn)) (return))
  44.       (when (and (zerop (#_GetProcessInformation psn pinfo))
  45.                  (= (pref pinfo :ProcessInfoRec.processType) file-type)
  46.                  (eq (pref pinfo :ProcessInfoRec.processSignature) signature))
  47.         (return-from find-process t)))))
  48.  
  49.  
  50. ;;Launches the application specified by fsspec. It's process id is returned
  51. ;;in psn. If bring-to-front-p is non-nil, it's made the active application.
  52. ;;Returns t/nil indicating success/failure.
  53. (defun launch-app (fsspec psn bring-to-front-p)
  54.   (let ((flags (+ #$launchContinue
  55.                   #$launchNoFileFlags
  56.                   (if bring-to-front-p 0 #$launchDontSwitch))))
  57.     (rlet ((pb :LaunchParamBlockRec
  58.                :launchBlockID       #$extendedBlock
  59.                :launchEPBLength     #$extendedBlockLen
  60.                :launchControlFlags  flags
  61.                :launchAppSpec       fsspec
  62.                :launchAppParameters (%null-ptr)))
  63.       (when (zerop (#_LaunchApplication pb))
  64.         (pset psn :ProcessSerialNumber (pref pb :LaunchParamBlockRec.launchProcessSN))
  65.         t))))
  66.  
  67. ;;Sends a quit Apple Event to the specified process
  68. (defun AE-send-quit (psn)
  69.   (rlet ((ae-addr :AEAddressDesc)
  70.          (ae :AppleEvent)
  71.          (ae-reply :AppleEvent))
  72.     (when (and (zerop (#_AECreateDesc #$typeProcessSerialNumber psn (rlength :ProcessSerialNumber) ae-addr))
  73.                (zerop (#_AECreateAppleEvent #$kCoreEventClass #$kAEQuitApplication ae-addr 0 #$kAnyTransactionID ae)))
  74.       (prog1
  75.         (zerop (#_AESend ae ae-reply #$kAEWaitReply #$kAENormalPriority #$kNoTimeOut (%null-ptr) (%null-ptr)))
  76.         (#_AEDisposeDesc ae-addr)
  77.         (#_AEDisposeDesc ae)
  78.         (#_AEDisposeDesc ae-reply)))))
  79.  
  80. (defun restart-Finder ()
  81.   (rlet ((fsspec :FSSpec)
  82.          (psn :ProcessSerialNumber))
  83.     
  84.     ;;kill the FileSharing Extension if it's around
  85.     (when (find-process "INIT" "hhgg" psn fsspec)
  86.       (unless (AE-send-quit psn) (error "problem killing File Sharing Extension.")))
  87.     
  88.     ;;kill & restart the Finder
  89.     (when (find-process "FNDR" "MACS" psn fsspec)
  90.       (unless (AE-send-quit psn) "problem killing Finder.")
  91.       (unless (launch-app fsspec psn t) (error "problem launching Finder"))
  92.       
  93.       ;;wait till Finder becomes the front process
  94.       ;;(actually, this is only necessary if you're planning to ExitToShell right away)
  95.       (rlet ((my-psn :ProcessSerialNumber)
  96.              (flag :Boolean))
  97.         (#_GetCurrentProcess my-psn)
  98.         (loop
  99.           (#_GetFrontProcess psn)
  100.           (#_SameProcess psn my-psn flag)
  101.           (unless (%get-boolean flag) (return t)))))))
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ;;DTDB stuff
  105.  
  106. (defun DTDB-p (vRefNum)
  107.   (with-returned-pstrs ((name_p ""))
  108.     (rlet ((vparams :GetVolParmsInfoBuffer)
  109.            (pb :HParamBlockRec
  110.                :ioVRefNum vRefNum
  111.                :ioNamePtr name_p
  112.                :ioBuffer vparams
  113.                :ioReqCount (rlength :GetVolParmsInfoBuffer)))
  114.       (trap-nz-echeck (#_PBHGetVolParms pb))
  115.       (and
  116.        (logbitp #$bHasDesktopMgr (pref vparams :GetVolParmsInfoBuffer.vMAttrib))
  117.        (not (logbitp #$bHasExtFSVol (pref vparams :GetVolParmsInfoBuffer.vMAttrib)))))))
  118.  
  119. (defun DTDB-vstrip-APPL (creator vRefNum)
  120.   (let ((count 0))
  121.     (with-returned-pstrs ((name_p ""))
  122.       (rlet ((pb :DTPBRec
  123.                  :ioNamePtr name_p
  124.                  :ioVRefNum vRefNum
  125.                  :ioIndex 1
  126.                  :ioFileCreator creator))
  127.         (trap-nz-echeck (#_PBDTGetPath pb))
  128.         (loop
  129.           (unless (zerop (#_PBDTGetAPPL pb))
  130.             (unless (= (pref pb :DTPBRec.ioResult) #$afpItemNotFound)
  131.               (error "error calling GetAPPL (~a)" (pref pb :DTPBRec.ioResult)))
  132.             (when (plusp count)
  133.               (#_PBDTFlush pb))
  134.             (return count))
  135.           (pset pb :DTPBRec.ioDirID (pref pb :DTPBRec.ioAPPLParID))
  136.           (trap-nz-echeck (#_PBDTRemoveAPPL pb))
  137.           (incf count))))))
  138.  
  139. (defun DTDB-strip-APPL (creator)
  140.   ;should use (#_GetVCBQHdr) or constant #$VCBQHdr = x0356
  141.   (with-macptrs ((q-ptr  (pref (%int-to-ptr #x0356) :QHdr.qHead)))
  142.     (loop
  143.       (when (%null-ptr-p q-ptr) (return))
  144.       (when (DTDB-p (pref q-ptr :VCB.vcbVRefNum))
  145.         (format t "~%stripping ~a, ~a BNDLs stripped"
  146.                 (pref q-ptr :VCB.vcbvn)
  147.                 (DTDB-vstrip-APPL creator (pref q-ptr :VCB.vcbVRefNum)))
  148.       (%setf-macptr q-ptr (pref q-ptr :VCB.qLink))))))
  149.  
  150. (defun DTDB-vshow-APPL (creator vRefNum)
  151.   (with-returned-pstrs ((name_p ""))
  152.     (rlet ((pb :DTPBRec
  153.                :ioNamePtr name_p
  154.                :ioVRefNum vRefNum
  155.                :ioIndex 1
  156.                :ioFileCreator creator))
  157.       (trap-nz-echeck (#_PBDTGetPath pb))
  158.       (loop
  159.         (unless (zerop (#_PBDTGetAPPL pb))
  160.           (#_PBDTFlush pb)
  161.           (return (1- (pref pb :DTPBRec.ioIndex))))
  162.         (pset pb :DTPBRec.ioDirID (pref pb :DTPBRec.ioAPPLParID))
  163.         (format t "~%~2@s: fn = ~s,  dirID = ~s"
  164.                 (pref pb :DTPBRec.ioIndex)
  165.                 (%get-string (pref pb :DTPBRec.ioNamePtr))
  166.                 (pref pb :DTPBRec.ioAPPLParID))
  167.         (incf (pref pb :DTPBRec.ioIndex))))))
  168.  
  169. (defun DTDB-show-APPL (creator)
  170.   ;should use (#_GetVCBQHdr) or constant #$VCBQHdr = x0356
  171.   (with-macptrs ((q-ptr  (pref (%int-to-ptr #x0356) :QHdr.qHead)))
  172.     (loop
  173.       (when (%null-ptr-p q-ptr) (return))
  174.       (when (DTDB-p (pref q-ptr :VCB.vcbVRefNum))
  175.         (format t "~%----------~%volume = ~a" (pref q-ptr :VCB.vcbVN))
  176.         (DTDB-vshow-APPL creator (pref q-ptr :VCB.vcbVRefNum))
  177.         (terpri))
  178.       (%setf-macptr q-ptr (pref q-ptr :VCB.qLink)))))
  179.  
  180. (defun DTDB-icon-info (icon-type)
  181.   (values
  182.    (case icon-type
  183.      ((#.#$kLargeIcon #.#$kLarge4BitIcon #.#$kLarge8BitIcon) 32)
  184.      ((#.#$kSmallIcon #.#$kSmall4BitIcon #.#$kSmall8BitIcon) 16))
  185.    (case icon-type
  186.      ((#.#$kLargeIcon     #.#$kSmallIcon)     1)
  187.      ((#.#$kLarge4BitIcon #.#$kSmall4BitIcon) 4)
  188.      ((#.#$kLarge8BitIcon #.#$kSmall8BitIcon) 8))))
  189.  
  190. (defun DTDB-flip-icon (icon-buf icon-buf-size icon-type)
  191.   (flet ((flip (icon-buf icon-buf-size rows)
  192.            (let* ((row-bytes (round icon-buf-size rows))
  193.                   (nrow-bytes (- row-bytes)))
  194.              (with-macptrs ((top-buf-ptr icon-buf)
  195.                             (bot-buf-ptr (%inc-ptr icon-buf (- icon-buf-size row-bytes))))
  196.                (%stack-block ((row-buf row-bytes))
  197.                  (dotimes (i (round rows 2))
  198.                    (#_BlockMove top-buf-ptr row-buf     row-bytes)
  199.                    (#_BlockMove bot-buf-ptr top-buf-ptr row-bytes)
  200.                    (#_BlockMove row-buf     bot-buf-ptr row-bytes)
  201.                    (%incf-ptr top-buf-ptr row-bytes)
  202.                    (%incf-ptr bot-buf-ptr nrow-bytes)))))))
  203.     (multiple-value-bind (rows depth) (DTDB-icon-info icon-type)
  204.       (when (and rows depth)
  205.         (unless (= (round icon-buf-size (if (= depth 1) 2 1)) (round (* rows rows depth) 8))
  206.           (error "icon data seems wrong: type=~s rows=~s, depth=~s, buf-size = ~s"
  207.                  icon-type rows depth icon-buf-size))
  208.         (cond
  209.          ((= depth 1)
  210.           (let ((half-buf-size (round icon-buf-size 2)))
  211.             (flip icon-buf half-buf-size rows)
  212.             (flip (%inc-ptr icon-buf half-buf-size) half-buf-size rows)))
  213.          (t
  214.           (flip icon-buf icon-buf-size rows)))))))
  215.  
  216. (defun DTDB-vflip-APPL (creator vRefNum)
  217.   (let ((count 0))
  218.     (with-returned-pstrs ((name_p ""))
  219.       (rlet ((pb :DTPBRec
  220.                  :ioNamePtr name_p
  221.                  :ioVRefNum vRefNum
  222.                  :ioIndex 1
  223.                  :ioFileCreator creator))
  224.         (trap-nz-echeck (#_PBDTGetPath pb))
  225.         (loop
  226.           (unless (zerop (#_PBDTGetIconInfo pb))
  227.             (unless (= (pref pb :DTPBRec.ioResult) #$afpItemNotFound)
  228.               (error "error calling GetIconInfo (~a)" (pref pb :DTPBRec.ioResult)))
  229.             (when (plusp count)
  230.               (#_PBDTFlush pb))
  231.             (return count))
  232.           (let ((icon-buf-size (pref pb :DTPBRec.ioDTActCount)))
  233.             (%stack-block ((icon-buf icon-buf-size))
  234.               (pset pb :DTPBRec.ioDTReqCount icon-buf-size)
  235.               (pset pb :DTPBRec.ioDTBuffer   icon-buf)
  236.               (trap-nz-echeck (#_PBDTGetIcon pb))
  237.               (DTDB-flip-icon icon-buf icon-buf-size (pref pb :DTPBRec.ioIconType))
  238.               (trap-nz-echeck (#_PBDTAddIcon pb))))
  239.           (incf count)
  240.           (incf (pref pb :DTPBRec.ioIndex)))))))
  241.  
  242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  243. ;;file mgr stuff
  244.  
  245. (defun path-to-FSSpec (pathname fsspec)
  246.   (with-pstrs ((fn (mac-namestring pathname)))
  247.     (trap-nz-echeck (#_FSMakeFSSpec 0 0 fn fsspec))))
  248.  
  249. (defun clear-hasBeenInited-bit (pathname)
  250.   (rlet ((fsspec    :FSSpec)
  251.          (fndr-info :FInfo))
  252.     (path-to-FSSpec pathname fsspec)
  253.       (trap-nz-echeck (#_FSpGetFInfo fsspec fndr-info))
  254.       (pset fndr-info :FInfo.fdFlags (logand (pref fndr-info :FInfo.fdFlags) #xFEFF))
  255.       (trap-nz-echeck (#_FSpSetFInfo fsspec fndr-info))))
  256.  
  257. (defun test-hasBeenInited-bit (pathname)
  258.   (rlet ((fsspec    :FSSpec)
  259.          (fndr-info :FInfo))
  260.     (path-to-FSSpec pathname fsspec)
  261.     (trap-nz-echeck (#_FSpGetFInfo fsspec fndr-info))
  262.     (logbitp 8 (pref fndr-info :FInfo.fdFlags))))
  263.  
  264. (defun touch-hasBeenInited-bit (pathname)
  265.   (rlet ((fsspec :FSSpec))
  266.     (path-to-FSSpec pathname fsspec)
  267.     (with-returned-pstrs ((par-dir-name_p ""))
  268.       (rlet ((pb :CInfoPBRec
  269.                  :ioDrDirID (pref fsspec :FSSpec.parId)
  270.                  :ioVRefNum (pref fsspec :FSSpec.vRefNum)
  271.                  :ioNamePtr par-dir-name_p
  272.                  :ioFDirIndex -1))
  273.         (trap-nz-echeck (#_PBGetCatInfo pb))
  274.         (pset pb :CInfoPBRec.ioDrDirId (pref pb :CInfoPBRec.ioDrParID))
  275.         (pset pb :CInfoPBRec.ioFDirIndex 0)
  276.         (#_GetDateTime (%inc-ptr pb (foffset :CInfoPBRec :ioDrMdDat)))
  277.         (trap-nz-echeck (#_PBSetCatInfo pb))))))
  278.  
  279. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  280.  
  281. (defun bang-it (pathname &key (restart-p t))
  282.   (unless pathname (setf pathname (choose-file-dialog :mac-file-type "APPL")))
  283.   (unless (probe-file pathname) (error "~s not found."))
  284.   (DTDB-strip-APPL (mac-file-creator pathname))
  285.   (clear-hasBeenInited-bit pathname)
  286.   (when restart-p (restart-Finder)))
  287.  
  288. (defun flip-it (pathname &key (restart-p t))
  289.   (rlet ((spec :FSSpec))
  290.     (path-to-FSSpec pathname spec)
  291.     (DTDB-vflip-APPL (mac-file-creator pathname) (pref spec :FSSpec.vRefNum)))
  292.   (when restart-p (restart-Finder)))
  293.  
  294. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  295.  
  296. #|
  297.  
  298. (rlet ((spec :FSSpec))
  299.   (path-to-FSSpec "HD:" spec)
  300.   (print-record spec :FSSpec))
  301.  
  302. (flip-it (choose-file-dialog :mac-file-type "APPL") :restart-p t)
  303.  
  304. |#